home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / symbol.d < prev    next >
Text File  |  1987-06-03  |  12KB  |  623 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     symbol.d
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. object siSpname;
  14.  
  15. object string_register;
  16.  
  17. object gensym_prefix;
  18. int gensym_counter;
  19. object gentemp_prefix;
  20. int gentemp_counter;
  21.  
  22. object token;
  23.  
  24. set_up_string_register(s)
  25. char *s;
  26. {
  27.     string_register->st.st_fillp =
  28.     string_register->st.st_dim = strlen(s);
  29.     string_register->st.st_self = s;
  30. }
  31.  
  32. object
  33. make_symbol(st)
  34. object st;
  35. {
  36.     object x;
  37.     int i;
  38.  
  39.     x = alloc_object(t_symbol);
  40.     x->s.s_dbind = OBJNULL;
  41.     x->s.s_sfdef = NOT_SPECIAL;
  42.     x->s.s_fillp = st->st.st_fillp;
  43.     x->s.s_self = NULL;
  44.     x->s.s_gfdef = OBJNULL;
  45.     x->s.s_plist = Cnil;
  46.     x->s.s_hpack = Cnil;
  47.     x->s.s_stype = (short)stp_ordinary;
  48.     x->s.s_mflag = FALSE;
  49.     vs_push(x);
  50.     if (st->st.st_self < heap_end)
  51.         x->s.s_self = st->st.st_self;        
  52.     else {
  53.         x->s.s_self = alloc_relblock(x->s.s_fillp);
  54.         for (i = 0;  i < x->s.s_fillp;  i++)
  55.             x->s.s_self[i] = st->st.st_self[i];
  56.     }
  57.     return(vs_pop);
  58. }
  59.  
  60. /*
  61.     Make_ordinary(s) makes an ordinary symbol from C string s
  62.     and interns it in lisp package as an external symbol.
  63. */
  64. object
  65. make_ordinary(s)
  66. char *s;
  67. {
  68.     int i, j;
  69.     object x, l, *ep;
  70.     vs_mark;
  71.  
  72.     set_up_string_register(s);
  73.     j = pack_hash(string_register);
  74.     ep = &lisp_package->p.p_external[j];
  75.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  76.         if (string_eq(l->c.c_car, string_register))
  77.             return(l->c.c_car);
  78.     x = make_symbol(string_register);
  79.     vs_push(x);
  80.     x->s.s_hpack = lisp_package;
  81.     *ep = make_cons(x, *ep);
  82.     vs_reset;
  83.     return(x);
  84. }
  85.  
  86. /*
  87.     Make_special(s, v) makes a special variable from C string s
  88.     with initial value v in lisp package.
  89. */
  90. object
  91. make_special(s, v)
  92. char *s;
  93. object v;
  94. {
  95.     object x;
  96.  
  97.     x = make_ordinary(s);
  98.     x->s.s_stype = (short)stp_special;
  99.     x->s.s_dbind = v;
  100.     return(x);
  101. }
  102.  
  103. /*
  104.     Make_constant(s, v) makes a constant from C string s
  105.     with constant value v in lisp package.
  106. */
  107. object
  108. make_constant(s, v)
  109. char *s;
  110. object v;
  111. {
  112.     object x;
  113.  
  114.     x = make_ordinary(s);
  115.     x->s.s_stype = (short)stp_constant;
  116.     x->s.s_dbind = v;
  117.     return(x);
  118. }
  119.  
  120. /*
  121.     Make_si_ordinary(s) makes an ordinary symbol from C string s
  122.     and interns it in system package as an external symbol.
  123.     It assumes that the (only) package used by system is lisp.
  124. */
  125. object
  126. make_si_ordinary(s)
  127. char *s;
  128. {
  129.     int i, j;
  130.     object x, l, *ep;
  131.     vs_mark;
  132.  
  133.     set_up_string_register(s);
  134.     j = pack_hash(string_register);
  135.     ep = &system_package->p.p_external[j];
  136.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  137.         if (string_eq(l->c.c_car, string_register))
  138.             return(l->c.c_car);
  139.     for (l = lisp_package->p.p_external[j];
  140.          type_of(l) == t_cons;
  141.          l = l->c.c_cdr)
  142.         if (string_eq(l->c.c_car, string_register))
  143.             error("name conflict --- can't make_si_ordinary");
  144.     x = make_symbol(string_register);
  145.     vs_push(x);
  146.     x->s.s_hpack = system_package;
  147.     *ep = make_cons(x, *ep);
  148.     vs_reset;
  149.     return(x);
  150. }
  151.  
  152. /*
  153.     Make_si_special(s, v) makes a special variable from C string s
  154.     with initial value v in system package.
  155. */
  156. object
  157. make_si_special(s, v)
  158. char *s;
  159. object v;
  160. {
  161.     object x;
  162.  
  163.     x = make_si_ordinary(s);
  164.     x->s.s_stype = (short)stp_special;
  165.     x->s.s_dbind = v;
  166.     return(x);
  167. }
  168.  
  169. /*
  170.     Make_si_constant(s, v) makes a constant from C string s
  171.     with constant value v in system package.
  172. */
  173. object
  174. make_si_constant(s, v)
  175. char *s;
  176. object v;
  177. {
  178.     object x;
  179.  
  180.     x = make_si_ordinary(s);
  181.     x->s.s_stype = (short)stp_constant;
  182.     x->s.s_dbind = v;
  183.     return(x);
  184. }
  185.  
  186. /*
  187.     Make_keyword(s) makes a keyword from C string s.
  188. */
  189. object
  190. make_keyword(s)
  191. char *s;
  192. {
  193.     int i, j;
  194.     object x, l, *ep;
  195.     vs_mark;
  196.  
  197.     set_up_string_register(s);
  198.     j = pack_hash(string_register);
  199.     ep = &keyword_package->p.p_external[j];
  200.     for (l = *ep;  type_of(l) == t_cons;  l = l->c.c_cdr)
  201.         if (string_eq(l->c.c_car, string_register))
  202.             return(l->c.c_car);
  203.     x = make_symbol(string_register);
  204.     vs_push(x);
  205.     x->s.s_hpack = keyword_package;
  206.     x->s.s_stype = (short)stp_constant;
  207.     x->s.s_dbind = x;
  208.     *ep = make_cons(x, *ep);
  209.     vs_reset;
  210.     return(x);
  211. }
  212.  
  213. object
  214. symbol_value(s)
  215. object s;
  216. {
  217. /*
  218.     if (type_of(s) != t_symbol)
  219.         FEinvalid_variable("~S is not a symbol.", s);
  220. */
  221.     if (s->s.s_dbind == OBJNULL)
  222.         FEunbound_variable(s);
  223.     return(s->s.s_dbind);
  224. }
  225.  
  226. object
  227. getf(place, indicator, deflt)
  228. object place, indicator, deflt;
  229. {
  230.     object l;
  231.  
  232.     for (l = place;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  233.         if (endp(l->c.c_cdr))
  234.             odd_plist(place);
  235.         if (l->c.c_car == indicator)
  236.             return(l->c.c_cdr->c.c_car);
  237.     }
  238.     return(deflt);
  239. }
  240.  
  241. object
  242. get(s, p, d)
  243. object s, p;
  244. {
  245.     if (type_of(s) != t_symbol)
  246.         not_a_symbol(s);
  247.     return(getf(s->s.s_plist, p, d));
  248. }
  249.  
  250. /*
  251.     Putf(p, v, i) puts value v for property i to property list p
  252.     and returns the resulting property list.
  253. */
  254. object
  255. putf(p, v, i)
  256. object p, v, i;
  257. {
  258.     object l, l0 = p;
  259.     vs_mark;
  260.  
  261.     for (l = p;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  262.         if (endp(l->c.c_cdr))
  263.             odd_plist(l0);
  264.         if (l->c.c_car == i) {
  265.             l->c.c_cdr->c.c_car = v;
  266.             return(p);
  267.         }
  268.     }
  269.     l = make_cons(v, p);
  270.     vs_push(l);
  271.     l = make_cons(i, l);
  272.     vs_reset;
  273.     return(l);
  274. }
  275.  
  276. object
  277. putprop(s, v, p)
  278. object s, v, p;
  279. {
  280.     if (type_of(s) != t_symbol)
  281.         not_a_symbol(s);
  282.     s->s.s_plist = putf(s->s.s_plist, v, p);
  283.     return(v);
  284. }
  285.  
  286. /*
  287.     Remf(p, i) removes property i
  288.     from the property list pointed by p,
  289.     which is a pointer to an object.
  290.     The returned value of remf(p, i) is:
  291.  
  292.         TRUE    if the property existed
  293.         FALSE    otherwise.
  294. */
  295. bool
  296. remf(p, i)
  297. object *p, i;
  298. {
  299.     object l0 = *p;
  300.  
  301.     for(;  !endp(*p);  p = &(*p)->c.c_cdr->c.c_cdr) {
  302.         if (endp((*p)->c.c_cdr))
  303.             odd_plist(l0);
  304.         if ((*p)->c.c_car == i) {
  305.             *p = (*p)->c.c_cdr->c.c_cdr;
  306.             return(TRUE);
  307.         }
  308.     }
  309.     return(FALSE);
  310. }
  311.  
  312. object
  313. remprop(s, p)
  314. object s, p;
  315. {
  316.     if (type_of(s) != t_symbol)
  317.         not_a_symbol(s);
  318.     if (remf(&s->s.s_plist, p))
  319.         return(Ct);
  320.     else
  321.         return(Cnil);
  322. }
  323.  
  324. bool
  325. keywordp(s)
  326. object s;
  327. {
  328.     return(type_of(s) == t_symbol && s->s.s_hpack == keyword_package);
  329. /*
  330.     if (type_of(s) != t_symbol) {
  331.         vs_push(s);
  332.         check_type_symbol(&vs_head);
  333.         vs_pop;
  334.     }
  335.     if (s->s.s_hpack == OBJNULL)
  336.         return(FALSE);
  337.     return(s->s.s_hpack == keyword_package);
  338. */
  339. }
  340.  
  341. @(defun get (sym indicator &optional deflt)
  342. @
  343.     check_type_symbol(&sym);
  344.     @(return `getf(sym->s.s_plist, indicator, deflt)`)
  345. @)
  346.  
  347. Lremprop()
  348. {
  349.     check_arg(2);
  350.  
  351.     check_type_symbol(&vs_base[0]);
  352.     if (remf(&vs_base[0]->s.s_plist, vs_base[1]))
  353.         vs_base[0] = Ct;
  354.     else
  355.         vs_base[0] = Cnil;
  356.     vs_pop;
  357. }
  358.  
  359. Lsymbol_plist()
  360. {
  361.     check_arg(1);
  362.  
  363.     check_type_symbol(&vs_base[0]);
  364.     vs_base[0] = vs_base[0]->s.s_plist;
  365. }
  366.  
  367. @(defun getf (place indicator &optional deflt)
  368. @
  369.     @(return `getf(place, indicator, deflt)`)
  370. @)
  371.  
  372. @(defun get_properties (place indicator_list)
  373.     object l, m;
  374. @
  375.     for (l = place;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
  376.         if (endp(l->c.c_cdr))
  377.             odd_plist(place);
  378.         for (m = indicator_list;  !endp(m);  m = m->c.c_cdr)
  379.             if (l->c.c_car == m->c.c_car)
  380.                 @(return `l->c.c_car`
  381.                      `l->c.c_cdr->c.c_car`
  382.                      l)
  383.     }
  384.     @(return Cnil Cnil Cnil)
  385. @)
  386.  
  387. Lsymbol_name()
  388. {
  389.     int i;
  390.     object x, y;
  391.  
  392.     check_arg(1);
  393.     check_type_symbol(&vs_base[0]);
  394.     x = vs_base[0];
  395.     if ((y = getf(x->s.s_plist, siSpname, Cnil)) != Cnil) {
  396.         vs_base[0] = y;
  397.         return;
  398.     }
  399.     y = alloc_simple_string(x->s.s_fillp);
  400.     vs_push(y);
  401.     if (x->s.s_self < heap_end)
  402.         y->st.st_self = x->s.s_self;
  403.     else {
  404.         y->st.st_self = alloc_relblock(x->s.s_fillp);
  405.         for (i = 0;  i < x->s.s_fillp;  i++)
  406.             y->st.st_self[i] = x->s.s_self[i];
  407.     }
  408.     x->s.s_plist = putf(x->s.s_plist, y, siSpname);
  409.     vs_base++;
  410. }
  411.  
  412. Lmake_symbol()
  413. {
  414.     check_arg(1);
  415.  
  416.     check_type_string(&vs_base[0]);
  417.     vs_base[0] = make_symbol(vs_base[0]);
  418. }
  419.  
  420. @(defun copy_symbol (sym &optional cp &aux x)
  421. @
  422.     check_type_symbol(&sym);
  423.     x = make_symbol(sym);
  424.     if (cp == Cnil)
  425.         @(return x)
  426.     x->s.s_stype = sym->s.s_stype;
  427.     x->s.s_dbind = sym->s.s_dbind;
  428.     x->s.s_mflag = sym->s.s_mflag;
  429.     x->s.s_gfdef = sym->s.s_gfdef;
  430.     x->s.s_plist = copy_list(sym->s.s_plist);
  431.     @(return x)
  432. @)
  433.  
  434. @(defun gensym (&optional (x gensym_prefix) &aux sym)
  435.     int i, j;
  436. @
  437.     if (type_of(x) == t_string)
  438.         gensym_prefix = x;
  439.     else {
  440.         check_type_non_negative_integer(&x);
  441.         if (type_of(x) == t_fixnum)
  442.             gensym_counter = fix(x);
  443.         else
  444.             gensym_counter = 0;
  445.             /*  incorrect implementation  */
  446.     }
  447.     for (j = gensym_counter, i = 0;  j > 0;  j /= 10)
  448.         i++;
  449.     if (i == 0)
  450.         i++;
  451.     i += gensym_prefix->st.st_fillp;
  452.     set_up_string_register("");
  453.     sym = make_symbol(string_register);
  454.     sym->s.s_fillp = i;
  455.     sym->s.s_self = alloc_relblock(i);
  456.     for (j = 0;  j < gensym_prefix->st.st_fillp;  j++)
  457.         sym->s.s_self[j] = gensym_prefix->st.st_self[j];
  458.     if ((j = gensym_counter) == 0)
  459.         sym->s.s_self[--i] = '0';
  460.     else
  461.         for (;  j > 0;  j /= 10)
  462.             sym->s.s_self[--i] = j%10 + '0';
  463.     gensym_counter++;
  464.     @(return sym)
  465. @)
  466.  
  467. @(defun gentemp (&optional (prefix gentemp_prefix)
  468.                (pack `current_package()`)
  469.          &aux smbl)
  470.     int i, j;
  471. @
  472.     check_type_string(&prefix);
  473.     check_type_package(&pack);
  474. /*
  475.     gentemp_counter = 0;
  476. */
  477. ONCE_MORE:
  478.     for (j = gentemp_counter, i = 0;  j > 0;  j /= 10)
  479.         i++;
  480.     if (i == 0)
  481.         i++;
  482.     i += prefix->st.st_fillp;
  483.     set_up_string_register("");
  484.     string_register->st.st_fillp = string_register->st.st_dim = i;
  485.     string_register->st.st_self = alloc_relblock(i);
  486.     for (j = 0;  j < prefix->st.st_fillp;  j++)
  487.         string_register->st.st_self[j] = prefix->st.st_self[j];
  488.     if ((j = gentemp_counter) == 0)
  489.         string_register->st.st_self[--i] = '0';
  490.     else
  491.         for (;  j > 0;  j /= 10)
  492.             string_register->st.st_self[--i] = j%10 + '0';
  493.     gentemp_counter++;
  494.     smbl = intern(string_register, pack);
  495.     if (intern_flag != 0)
  496.         goto ONCE_MORE;
  497.     @(return smbl)
  498. @)
  499.  
  500. Lsymbol_package()
  501. {
  502.     check_arg(1);
  503.  
  504.     check_type_symbol(&vs_base[0]);
  505.     vs_base[0] = vs_base[0]->s.s_hpack;
  506. }
  507.  
  508. Lkeywordp()
  509. {
  510.     check_arg(1);
  511.  
  512.     if (type_of(vs_base[0]) == t_symbol && keywordp(vs_base[0]))
  513.         vs_base[0] = Ct;
  514.     else
  515.         vs_base[0] = Cnil;
  516. }
  517.  
  518. /*
  519.     (SI:PUT-F plist value indicator)
  520.     returns the new property list with value for property indicator.
  521.     It will be used in SETF for GETF.
  522. */
  523. siLput_f()
  524. {
  525.     check_arg(3);
  526.  
  527.     vs_base[0] = putf(vs_base[0], vs_base[1], vs_base[2]);
  528.     vs_top = vs_base+1;
  529. }
  530.  
  531. /*
  532.     (SI:REM-F plist indicator) returns two values:
  533.  
  534.         * the new property list
  535.           in which property indcator is removed
  536.  
  537.         * T    if really removed
  538.           NIL    otherwise.
  539.  
  540.     It will be used for macro REMF.
  541. */
  542. siLrem_f()
  543. {
  544.     check_arg(2);
  545.  
  546.     if (remf(&vs_base[0], vs_base[1]))
  547.         vs_base[1] = Ct;
  548.     else
  549.         vs_base[1] = Cnil;
  550. }
  551.  
  552. siLset_symbol_plist()
  553. {
  554.     check_arg(2);
  555.  
  556.     check_type_symbol(&vs_base[0]);
  557.     vs_base[0]->s.s_plist = vs_base[1];
  558.     vs_base[0] = vs_base[1];
  559.     vs_pop;
  560. }
  561.  
  562. siLputprop()
  563. {
  564.     check_arg(3);
  565.  
  566.     check_type_symbol(&vs_base[0]);
  567.     vs_base[0]->s.s_plist
  568.     = putf(vs_base[0]->s.s_plist, vs_base[1], vs_base[2]);
  569.     vs_base[0] = vs_base[1];
  570.     vs_top = vs_base+1;
  571. }
  572.  
  573. odd_plist(place)
  574. object place;
  575. {
  576.     FEerror("The length of the property-list ~S is odd.", 1, place);
  577. }
  578.  
  579.  
  580. init_symbol()
  581. {
  582.     string_register = alloc_simple_string(0);
  583.     gensym_prefix = make_simple_string("G");
  584.     gensym_counter = 0;
  585.     gentemp_prefix = make_simple_string("T");
  586.     gentemp_counter = 0;
  587.     token = alloc_simple_string(PAGESIZE);
  588.     token->st.st_fillp = 0;
  589.     token->st.st_self = alloc_contblock(PAGESIZE);
  590.     token->st.st_hasfillp = TRUE;
  591.     token->st.st_adjustable = TRUE;
  592.  
  593.     enter_mark_origin(&string_register);
  594.     enter_mark_origin(&gensym_prefix);
  595.     enter_mark_origin(&gentemp_prefix);
  596.     enter_mark_origin(&token);
  597. }
  598.  
  599. init_symbol_function()
  600. {
  601.     make_function("GET", Lget);
  602.     make_function("REMPROP", Lremprop);
  603.     make_function("SYMBOL-PLIST", Lsymbol_plist);
  604.     make_function("GETF", Lgetf);
  605.     make_function("GET-PROPERTIES", Lget_properties);
  606.     make_function("SYMBOL-NAME", Lsymbol_name);
  607.     make_function("MAKE-SYMBOL", Lmake_symbol);
  608.     make_function("COPY-SYMBOL", Lcopy_symbol);
  609.     make_function("GENSYM", Lgensym);
  610.     make_function("GENTEMP", Lgentemp);
  611.     make_function("SYMBOL-PACKAGE", Lsymbol_package);
  612.     make_function("KEYWORDP", Lkeywordp);
  613.  
  614.     make_si_function("PUT-F", siLput_f);
  615.     make_si_function("REM-F", siLrem_f);
  616.     make_si_function("SET-SYMBOL-PLIST", siLset_symbol_plist);
  617.  
  618.     make_si_function("PUTPROP", siLputprop);
  619.  
  620.     siSpname = make_si_ordinary("PNAME");
  621.     enter_mark_origin(&siSpname);
  622. }
  623.